Manipulation Check
Real / Fake
# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
mutate(Participant = fct_relevel(Participant, df |>
group_by(Participant) |>
summarize(Belief_Answer = mean(Belief_Answer)) |>
ungroup() |>
arrange(Belief_Answer) |>
pull(Participant) |>
as.character())) |>
# mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
geom_vline(xintercept = 0, linetype = "dotted") +
scale_y_discrete(expand = c(0.02, 0)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-0.95, 0, 0.95),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d() +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "grey", color = "white") +
ggside::scale_xsidey_continuous(expand = c(0, 0))
df |>
group_by(Participant, Belief) |>
summarize(n = n() / 108,
Confidence = mean(Belief_Confidence)) |>
pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |>
ungroup() |>
describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
##
## Parameter | Mean | 95% CI
## -------------------------------------
## n_Fake | 0.44 | [0.16, 0.64]
## n_Real | 0.56 | [0.36, 0.84]
## Confidence_Fake | 0.61 | [0.25, 1.00]
## Confidence_Real | 0.59 | [0.19, 0.99]
m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.084
## Stimulus | 0.098
Colinearity
IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")
correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | r | 95% CI | t(15118) | p
## ----------------------------------------------------------------------------
## Attractive | Beauty | 0.64 | [ 0.63, 0.65] | 103.09 | < .001***
## Attractive | Trustworthy | 0.10 | [ 0.09, 0.12] | 12.73 | < .001***
## Attractive | Familiar | 0.17 | [ 0.15, 0.18] | 21.05 | < .001***
## Beauty | Trustworthy | 0.25 | [ 0.23, 0.26] | 31.19 | < .001***
## Beauty | Familiar | -5.62e-03 | [-0.02, 0.01] | -0.69 | 0.489
## Trustworthy | Familiar | 0.07 | [ 0.06, 0.09] | 8.88 | < .001***
##
## p-value adjustment method: Holm (1979)
## Observations: 15120
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
for (y in IVs) {
if (x == y) next
print(paste(y, "~", x))
model <- glmmTMB::glmmTMB(as.formula(
paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
),
data = df,
family = glmmTMB::beta_family()
)
# model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
# random = list(Participant=~1, Stimulus=~1),
# data = df,
# family=mgcv::betar())
pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
pred$y <- y
pred <- data_rename(pred, x, "Score")
pred$x <- x
preds <- rbind(preds, pred)
dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
}
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"
dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
ggplot(aes(x = Score, y = Predicted)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
# geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
facet_grid(y ~ x, switch = "both") +
theme_modern() +
labs(title = "Collinearity in the Stimuli Ratings") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggnewscale::new_scale_fill() +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
Effect of Delay
model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Delay, y = Real)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#795548", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
hdi(df$Delay)
## 95% HDI: [1.23, 29.76]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
##
## Delay | Participant | Stimulus | Predicted | SE | 95% CI
## ----------------------------------------------------------------
## 0.00 | | | 0.58 | 0.02 | [0.53, 0.62]
## 60.00 | | | 0.54 | 0.03 | [0.48, 0.61]
##
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)
parameters::parameters(model, effects="fixed", exponentiate=TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.36 |
0.12 |
(1.15, 1.62) |
3.52 |
< .001 |
| Delay |
1.00 |
2.48e-03 |
(0.99, 1.00) |
-0.88 |
0.380 |
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.85 |
0.09 |
(0.66, 1.03) |
8.91 |
< .001 |
| Belief (Real) |
-0.09 |
0.06 |
(-0.21, 0.03) |
-1.41 |
0.158 |
| Belief (Fake) * Delay |
-2.48e-03 |
2.43e-03 |
(-7.25e-03, 2.29e-03) |
-1.02 |
0.309 |
| Belief (Real) * Delay |
-4.93e-03 |
1.93e-03 |
(-8.71e-03, -1.15e-03) |
-2.56 |
0.011 |
Determinants of Reality
make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
# Models
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
data = df,
family = "binomial"
)
y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
# gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
# data=df,
# algorithm="sampling",
# family = "bernoulli")
# trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
# slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
# trend$Trend <- interpret_pd(slope$pd)
# trend$group <- 0
# trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
sig1 <- data.frame(x = 0.5,
y = y_real[c(11, 31), "Predicted"],
Sex = y_real[c(11, 31), "Sex"])
param <- parameters::parameters(m_real, effects = "fixed", keep = var)
sig1$p <- c(min(param[str_detect(param$Parameter, sig1$Sex[1]), "p"]), min(param[str_detect(param$Parameter, sig1$Sex[2]), "p"]))
sig1$y <- sig1$y + ifelse(sig1$Sex == "Male", 0.03, -0.03)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = 0.5,
y = y_conf[c(11, 31, 51, 71), "Predicted"],
Sex = y_conf[c(11, 31, 51, 71), "Sex"],
Belief = y_conf[c(11, 31, 51, 71), "Belief"]) |>
arrange(Sex, Belief)
param <- parameters::parameters(m_conf, effects = "fixed", keep = var) |>
arrange(Parameter)
sig2$p <- c(min(param$p[c(1, 2)]), min(param$p[c(5, 6)]), min(param$p[c(3, 4)]), min(param$p[c(7, 8)]))
sig2$y <- sig2$y + ifelse(sig2$Belief == "Real", 0.02, -0.02)
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
scale_fill_gradientn(colors = c("white", fill), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_point2(alpha = 0.25, size = 4, color = "black") +
geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
# geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
# geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fill, color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
var = "Familiar", fill = "#2196F3"
)
Attractiveness
parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Sex (Female) * poly(Attractive, 2)1 |
8.18 |
3.16 |
(1.99, 14.38) |
2.59 |
0.010 |
| Sex (Male) * poly(Attractive, 2)1 |
12.45 |
3.99 |
(4.63, 20.27) |
3.12 |
0.002 |
| Sex (Female) * poly(Attractive, 2)2 |
4.74 |
2.96 |
(-1.06, 10.54) |
1.60 |
0.109 |
| Sex (Male) * poly(Attractive, 2)2 |
1.18 |
4.65 |
(-7.94, 10.30) |
0.25 |
0.800 |
performance::performance(rez_at$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_at$model_belief, by_group = TRUE) |>
display()
| Participant |
0.02 |
| Stimulus |
0.09 |
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Attractive, 2)1 |
1.42 |
2.22 |
(-2.93, 5.77) |
0.64 |
0.522 |
| Belief (Real) * SexFemale * poly(Attractive, 2)1 |
1.26 |
2.01 |
(-2.68, 5.21) |
0.63 |
0.529 |
| Belief (Fake) * SexMale * poly(Attractive, 2)1 |
1.13 |
3.08 |
(-4.90, 7.16) |
0.37 |
0.714 |
| Belief (Real) * SexMale * poly(Attractive, 2)1 |
1.32 |
2.55 |
(-3.68, 6.31) |
0.52 |
0.606 |
| Belief (Fake) * SexFemale * poly(Attractive, 2)2 |
4.85 |
2.16 |
(0.62, 9.08) |
2.25 |
0.025 |
| Belief (Real) * SexFemale * poly(Attractive, 2)2 |
3.88 |
1.87 |
(0.21, 7.55) |
2.07 |
0.038 |
| Belief (Fake) * SexMale * poly(Attractive, 2)2 |
-8.72 |
3.81 |
(-16.18, -1.25) |
-2.29 |
0.022 |
| Belief (Real) * SexMale * poly(Attractive, 2)2 |
4.63 |
2.80 |
(-0.86, 10.12) |
1.65 |
0.098 |
rez_at$p
Beauty
parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|>
display()
Fixed Effects
| Sex (Female) * poly(Beauty, 2)1 |
5.91 |
3.48 |
(-0.92, 12.74) |
1.70 |
0.090 |
| Sex (Male) * poly(Beauty, 2)1 |
8.86 |
3.91 |
(1.19, 16.52) |
2.27 |
0.023 |
| Sex (Female) * poly(Beauty, 2)2 |
4.42 |
3.13 |
(-1.71, 10.55) |
1.41 |
0.158 |
| Sex (Male) * poly(Beauty, 2)2 |
5.44 |
4.10 |
(-2.60, 13.47) |
1.33 |
0.185 |
performance::performance(rez_gl$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_gl$model_belief, by_group = TRUE)|>
display()
| Participant |
0.02 |
| Stimulus |
0.09 |
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Beauty, 2)1 |
0.08 |
2.36 |
(-4.56, 4.71) |
0.03 |
0.974 |
| Belief (Real) * SexFemale * poly(Beauty, 2)1 |
2.13 |
2.19 |
(-2.16, 6.42) |
0.97 |
0.331 |
| Belief (Fake) * SexMale * poly(Beauty, 2)1 |
-0.78 |
2.90 |
(-6.46, 4.90) |
-0.27 |
0.787 |
| Belief (Real) * SexMale * poly(Beauty, 2)1 |
1.95 |
2.40 |
(-2.74, 6.65) |
0.82 |
0.415 |
| Belief (Fake) * SexFemale * poly(Beauty, 2)2 |
7.23 |
2.33 |
(2.65, 11.80) |
3.10 |
0.002 |
| Belief (Real) * SexFemale * poly(Beauty, 2)2 |
1.14 |
2.02 |
(-2.81, 5.09) |
0.57 |
0.571 |
| Belief (Fake) * SexMale * poly(Beauty, 2)2 |
-6.26 |
3.15 |
(-12.44, -0.08) |
-1.99 |
0.047 |
| Belief (Real) * SexMale * poly(Beauty, 2)2 |
4.03 |
2.55 |
(-0.98, 9.03) |
1.58 |
0.115 |
rez_gl$p
Trustworthiness
parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Sex (Female) * poly(Trustworthy, 2)1 |
5.86 |
3.49 |
(-0.99, 12.71) |
1.68 |
0.093 |
| Sex (Male) * poly(Trustworthy, 2)1 |
3.17 |
3.78 |
(-4.25, 10.59) |
0.84 |
0.402 |
| Sex (Female) * poly(Trustworthy, 2)2 |
0.11 |
3.45 |
(-6.64, 6.87) |
0.03 |
0.974 |
| Sex (Male) * poly(Trustworthy, 2)2 |
1.47 |
3.81 |
(-6.00, 8.94) |
0.39 |
0.700 |
performance::performance(rez_tr$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_tr$model_belief, by_group = TRUE) |>
display()
| Participant |
0.02 |
| Stimulus |
0.09 |
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)1 |
-1.08 |
2.37 |
(-5.72, 3.56) |
-0.46 |
0.648 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)1 |
1.76 |
2.36 |
(-2.87, 6.39) |
0.75 |
0.456 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)1 |
-2.86 |
2.76 |
(-8.27, 2.56) |
-1.03 |
0.301 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)1 |
0.57 |
2.32 |
(-3.98, 5.12) |
0.25 |
0.806 |
| Belief (Fake) * SexFemale * poly(Trustworthy, 2)2 |
4.21 |
2.39 |
(-0.48, 8.89) |
1.76 |
0.078 |
| Belief (Real) * SexFemale * poly(Trustworthy, 2)2 |
7.46 |
2.29 |
(2.97, 11.95) |
3.25 |
0.001 |
| Belief (Fake) * SexMale * poly(Trustworthy, 2)2 |
-3.32 |
2.78 |
(-8.76, 2.12) |
-1.20 |
0.232 |
| Belief (Real) * SexMale * poly(Trustworthy, 2)2 |
1.42 |
2.43 |
(-3.34, 6.19) |
0.59 |
0.558 |
rez_tr$p
Familiarity
parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Sex (Female) * poly(Familiar, 2)1 |
-0.33 |
3.53 |
(-7.26, 6.59) |
-0.09 |
0.925 |
| Sex (Male) * poly(Familiar, 2)1 |
4.65 |
4.20 |
(-3.58, 12.89) |
1.11 |
0.268 |
| Sex (Female) * poly(Familiar, 2)2 |
0.18 |
3.31 |
(-6.32, 6.67) |
0.05 |
0.957 |
| Sex (Male) * poly(Familiar, 2)2 |
-2.74 |
4.53 |
(-11.61, 6.14) |
-0.60 |
0.546 |
performance::performance(rez_fa$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_fa$model_belief, by_group = TRUE) |>
display()
| Participant |
0.02 |
| Stimulus |
0.09 |
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Belief (Fake) * SexFemale * poly(Familiar, 2)1 |
-0.60 |
2.61 |
(-5.71, 4.52) |
-0.23 |
0.819 |
| Belief (Real) * SexFemale * poly(Familiar, 2)1 |
1.85 |
2.39 |
(-2.82, 6.53) |
0.78 |
0.437 |
| Belief (Fake) * SexMale * poly(Familiar, 2)1 |
-6.79 |
3.36 |
(-13.38, -0.21) |
-2.02 |
0.043 |
| Belief (Real) * SexMale * poly(Familiar, 2)1 |
8.02 |
2.74 |
(2.66, 13.38) |
2.93 |
0.003 |
| Belief (Fake) * SexFemale * poly(Familiar, 2)2 |
2.29 |
2.42 |
(-2.46, 7.03) |
0.95 |
0.345 |
| Belief (Real) * SexFemale * poly(Familiar, 2)2 |
-3.03 |
2.16 |
(-7.26, 1.20) |
-1.40 |
0.160 |
| Belief (Fake) * SexMale * poly(Familiar, 2)2 |
6.02 |
3.96 |
(-1.73, 13.77) |
1.52 |
0.128 |
| Belief (Real) * SexMale * poly(Familiar, 2)2 |
-1.10 |
2.71 |
(-6.41, 4.21) |
-0.40 |
0.686 |
rez_fa$p
Inter-Individual Correlates
plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
y_real <- estimate_relation(m_real, at = c(var), length = 21)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
Belief = y_conf[c(11, 31), "Belief"])
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Data
dat <- insight::get_data(m_conf) |>
group_by(Participant, Belief) |>
data_select(c("Participant", "Belief", var, "Belief_Confidence")) |>
mean_qi(.width = 0.5) |>
mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
ggnewscale::new_scale_fill() +
stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = ..density..), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
geom_line(data = y_real, aes(y = Predicted), size=1) +
geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
p
}
make_correlation <- function(x, y) {
cor <- correlation::correlation(x,
y,
bayesian = TRUE,
bayesian_prior = "medium.narrow",
sort = TRUE
) |>
datawizard::data_remove(c("ROPE_Percentage"))
cor$`BF (Spearman)` <- format_bf(
correlation::correlation(
x, y,
bayesian = TRUE,
ranktransform = TRUE,
bayesian_prior = "medium.narrow"
)$BF,
name = NULL, stars = TRUE
)
cor |>
arrange(desc(BF))
}
IPIP-6
f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.86 |
0.45 |
(-0.03, 1.76) |
1.90 |
0.058 |
| IPIP6 Extraversion |
-0.36 |
0.27 |
(-0.89, 0.17) |
-1.34 |
0.181 |
| IPIP6 Conscientiousness |
-0.04 |
0.28 |
(-0.59, 0.50) |
-0.16 |
0.874 |
| IPIP6 Neuroticism |
-0.46 |
0.31 |
(-1.06, 0.14) |
-1.52 |
0.129 |
| IPIP6 Openness |
-0.09 |
0.32 |
(-0.72, 0.55) |
-0.27 |
0.785 |
| IPIP6 HonestyHumility |
-0.40 |
0.28 |
(-0.95, 0.16) |
-1.39 |
0.163 |
| IPIP6 Agreeableness |
0.15 |
0.33 |
(-0.50, 0.81) |
0.46 |
0.645 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.69 |
0.77 |
(-0.82, 2.21) |
0.89 |
0.371 |
| Belief (Real) |
0.14 |
0.16 |
(-0.17, 0.45) |
0.91 |
0.362 |
| Belief (Fake) * IPIP6 Extraversion |
-0.25 |
0.46 |
(-1.16, 0.66) |
-0.54 |
0.588 |
| Belief (Real) * IPIP6 Extraversion |
-0.36 |
0.46 |
(-1.26, 0.55) |
-0.77 |
0.441 |
| Belief (Fake) * IPIP6 Conscientiousness |
-0.24 |
0.47 |
(-1.17, 0.68) |
-0.52 |
0.605 |
| Belief (Real) * IPIP6 Conscientiousness |
0.03 |
0.47 |
(-0.90, 0.95) |
0.06 |
0.952 |
| Belief (Fake) * IPIP6 Neuroticism |
-0.03 |
0.52 |
(-1.06, 0.99) |
-0.06 |
0.949 |
| Belief (Real) * IPIP6 Neuroticism |
0.06 |
0.52 |
(-0.96, 1.09) |
0.12 |
0.908 |
| Belief (Fake) * IPIP6 Openness |
0.57 |
0.55 |
(-0.52, 1.65) |
1.02 |
0.306 |
| Belief (Real) * IPIP6 Openness |
0.18 |
0.55 |
(-0.90, 1.27) |
0.33 |
0.740 |
| Belief (Fake) * IPIP6 HonestyHumility |
-1.26 |
0.49 |
(-2.22, -0.31) |
-2.59 |
0.010 |
| Belief (Real) * IPIP6 HonestyHumility |
-1.72 |
0.49 |
(-2.68, -0.77) |
-3.54 |
< .001 |
| Belief (Fake) * IPIP6 Agreeableness |
0.94 |
0.57 |
(-0.19, 2.07) |
1.64 |
0.102 |
| Belief (Real) * IPIP6 Agreeableness |
0.99 |
0.57 |
(-0.13, 2.12) |
1.73 |
0.083 |
p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip
sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.22 | [-0.36, -0.06] | 99.58%** | Beta (5.20 +- 5.20) | 10.90** | 8.29*
## Confidence_Fake | IPIP6_Openness | 0.15 | [ 0.00, 0.30] | 97.30%* | Beta (5.20 +- 5.20) | 1.41 | 2.89
## Confidence_Fake | IPIP6_HonestyHumility | -0.14 | [-0.30, 0.01] | 95.10% | Beta (5.20 +- 5.20) | 1.08 | 0.505
##
## Observations: 140
Narcissism
f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.15 |
0.32 |
(-0.47, 0.77) |
0.47 |
0.638 |
| FFNI AcclaimSeeking |
0.89 |
0.32 |
(0.26, 1.52) |
2.78 |
0.005 |
| FFNI Arrogance |
-0.08 |
0.32 |
(-0.71, 0.54) |
-0.27 |
0.791 |
| FFNI Authoritativeness |
-0.05 |
0.31 |
(-0.66, 0.55) |
-0.17 |
0.864 |
| FFNI Distrust |
0.37 |
0.28 |
(-0.18, 0.91) |
1.31 |
0.190 |
| FFNI Entitlement |
-0.27 |
0.33 |
(-0.92, 0.38) |
-0.82 |
0.414 |
| FFNI Exhibitionism |
0.03 |
0.28 |
(-0.52, 0.59) |
0.12 |
0.902 |
| FFNI Exploitativeness |
0.07 |
0.28 |
(-0.47, 0.62) |
0.27 |
0.789 |
| FFNI GrandioseFantasies |
-0.18 |
0.23 |
(-0.63, 0.26) |
-0.80 |
0.421 |
| FFNI Indifference |
-0.17 |
0.29 |
(-0.73, 0.39) |
-0.59 |
0.558 |
| FFNI LackOfEmpathy |
0.24 |
0.31 |
(-0.38, 0.85) |
0.76 |
0.448 |
| FFNI Manipulativeness |
-0.56 |
0.31 |
(-1.18, 0.05) |
-1.80 |
0.072 |
| FFNI NeedForAdmiration |
-0.39 |
0.31 |
(-1.00, 0.22) |
-1.24 |
0.213 |
| FFNI ReactiveAnger |
0.25 |
0.27 |
(-0.29, 0.78) |
0.90 |
0.367 |
| FFNI Shame |
-0.25 |
0.34 |
(-0.92, 0.41) |
-0.75 |
0.456 |
| FFNI ThrillSeeking |
0.02 |
0.21 |
(-0.39, 0.44) |
0.11 |
0.915 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.61 |
0.53 |
(-0.42, 1.65) |
1.16 |
0.246 |
| Belief (Real) |
-0.21 |
0.12 |
(-0.43, 0.02) |
-1.81 |
0.071 |
| Belief (Fake) * FFNI AcclaimSeeking |
1.76 |
0.54 |
(0.69, 2.82) |
3.23 |
0.001 |
| Belief (Real) * FFNI AcclaimSeeking |
1.83 |
0.54 |
(0.77, 2.88) |
3.38 |
< .001 |
| Belief (Fake) * FFNI Arrogance |
-0.63 |
0.54 |
(-1.69, 0.43) |
-1.17 |
0.242 |
| Belief (Real) * FFNI Arrogance |
-0.93 |
0.54 |
(-1.99, 0.12) |
-1.73 |
0.083 |
| Belief (Fake) * FFNI Authoritativeness |
-1.69 |
0.52 |
(-2.72, -0.67) |
-3.24 |
0.001 |
| Belief (Real) * FFNI Authoritativeness |
-1.76 |
0.52 |
(-2.78, -0.74) |
-3.39 |
< .001 |
| Belief (Fake) * FFNI Distrust |
-0.13 |
0.47 |
(-1.06, 0.79) |
-0.28 |
0.776 |
| Belief (Real) * FFNI Distrust |
0.42 |
0.47 |
(-0.50, 1.35) |
0.90 |
0.370 |
| Belief (Fake) * FFNI Entitlement |
0.34 |
0.56 |
(-0.75, 1.44) |
0.61 |
0.540 |
| Belief (Real) * FFNI Entitlement |
0.81 |
0.56 |
(-0.28, 1.90) |
1.45 |
0.147 |
| Belief (Fake) * FFNI Exhibitionism |
0.10 |
0.48 |
(-0.84, 1.03) |
0.20 |
0.840 |
| Belief (Real) * FFNI Exhibitionism |
0.02 |
0.48 |
(-0.91, 0.96) |
0.05 |
0.959 |
| Belief (Fake) * FFNI Exploitativeness |
-0.46 |
0.47 |
(-1.38, 0.47) |
-0.97 |
0.333 |
| Belief (Real) * FFNI Exploitativeness |
-0.31 |
0.47 |
(-1.24, 0.61) |
-0.67 |
0.504 |
| Belief (Fake) * FFNI GrandioseFantasies |
0.65 |
0.39 |
(-0.11, 1.41) |
1.68 |
0.093 |
| Belief (Real) * FFNI GrandioseFantasies |
0.54 |
0.39 |
(-0.21, 1.30) |
1.41 |
0.160 |
| Belief (Fake) * FFNI Indifference |
0.03 |
0.49 |
(-0.92, 0.99) |
0.07 |
0.948 |
| Belief (Real) * FFNI Indifference |
-0.41 |
0.49 |
(-1.36, 0.54) |
-0.84 |
0.400 |
| Belief (Fake) * FFNI LackOfEmpathy |
0.11 |
0.53 |
(-0.94, 1.15) |
0.20 |
0.843 |
| Belief (Real) * FFNI LackOfEmpathy |
0.05 |
0.53 |
(-0.99, 1.09) |
0.10 |
0.924 |
| Belief (Fake) * FFNI Manipulativeness |
0.64 |
0.53 |
(-0.40, 1.69) |
1.22 |
0.224 |
| Belief (Real) * FFNI Manipulativeness |
0.61 |
0.53 |
(-0.43, 1.64) |
1.15 |
0.250 |
| Belief (Fake) * FFNI NeedForAdmiration |
-0.60 |
0.53 |
(-1.64, 0.44) |
-1.12 |
0.261 |
| Belief (Real) * FFNI NeedForAdmiration |
-0.77 |
0.53 |
(-1.81, 0.27) |
-1.45 |
0.148 |
| Belief (Fake) * FFNI ReactiveAnger |
0.27 |
0.47 |
(-0.64, 1.19) |
0.59 |
0.556 |
| Belief (Real) * FFNI ReactiveAnger |
0.21 |
0.46 |
(-0.70, 1.11) |
0.45 |
0.656 |
| Belief (Fake) * FFNI Shame |
-0.13 |
0.58 |
(-1.26, 1.00) |
-0.22 |
0.823 |
| Belief (Real) * FFNI Shame |
-0.18 |
0.57 |
(-1.31, 0.94) |
-0.32 |
0.750 |
| Belief (Fake) * FFNI ThrillSeeking |
-0.47 |
0.36 |
(-1.17, 0.24) |
-1.29 |
0.199 |
| Belief (Real) * FFNI ThrillSeeking |
-0.34 |
0.36 |
(-1.05, 0.37) |
-0.94 |
0.348 |
p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1
p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF9800") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2
# p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_ThrillSeeking", fill = "#FF5722") + labs(x = "Narcissism (Thrill Seeking)")
# p_ffni3
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | FFNI_AcclaimSeeking | 0.21 | [ 0.06, 0.36] | 99.52%** | Beta (5.20 +- 5.20) | 9.18* | 29.02**
## Confidence_Fake | FFNI_GrandioseFantasies | 0.21 | [ 0.07, 0.36] | 99.67%** | Beta (5.20 +- 5.20) | 6.34* | 3.99*
## Confidence_Real | FFNI_GrandioseFantasies | 0.19 | [ 0.04, 0.34] | 99.02%** | Beta (5.20 +- 5.20) | 3.64* | 5.06*
## Confidence_Fake | FFNI_AcclaimSeeking | 0.18 | [ 0.03, 0.34] | 98.95%* | Beta (5.20 +- 5.20) | 3.09* | 3.46*
## n_Real | FFNI_AcclaimSeeking | 0.15 | [-0.01, 0.30] | 97.08%* | Beta (5.20 +- 5.20) | 1.51 | 1.58
## Confidence_Fake | FFNI_Manipulativeness | 0.14 | [-0.03, 0.28] | 95.73% | Beta (5.20 +- 5.20) | 1.14 | 0.801
##
## Observations: 140
cor_test(dfsub, "FFNI_Authoritativeness", "IPIP6_HonestyHumility")
## Parameter1 | Parameter2 | r | 95% CI | t(138) | p
## --------------------------------------------------------------------------------------------
## FFNI_Authoritativeness | IPIP6_HonestyHumility | -0.33 | [-0.47, -0.18] | -4.16 | < .001***
##
## Observations: 140
# cor_test(dfsub, "FFNI_ThrillSeeking", "IPIP6_HonestyHumility")
Social Anxiety
f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.24 |
0.14 |
(-0.02, 0.51) |
1.80 |
0.072 |
| Social Anxiety |
0.29 |
0.40 |
(-0.50, 1.08) |
0.71 |
0.476 |
| Social Phobia |
-0.20 |
0.36 |
(-0.91, 0.51) |
-0.55 |
0.582 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.94 |
0.21 |
(0.53, 1.36) |
4.45 |
< .001 |
| Belief (Real) |
-0.23 |
0.04 |
(-0.31, -0.15) |
-5.40 |
< .001 |
| Belief (Fake) * Social Anxiety |
-1.43 |
0.71 |
(-2.82, -0.05) |
-2.03 |
0.042 |
| Belief (Real) * Social Anxiety |
-1.07 |
0.70 |
(-2.45, 0.31) |
-1.53 |
0.127 |
| Belief (Fake) * Social Phobia |
1.22 |
0.63 |
(-0.01, 2.45) |
1.94 |
0.053 |
| Belief (Real) * Social Phobia |
0.98 |
0.63 |
(-0.25, 2.21) |
1.56 |
0.118 |
# p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
# p_social
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)
Intolerance to Uncertainty
f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.48 |
0.22 |
(0.04, 0.91) |
2.14 |
0.033 |
| IUS ProspectiveAnxiety |
-0.08 |
0.40 |
(-0.86, 0.71) |
-0.19 |
0.850 |
| IUS InhibitoryAnxiety |
-0.32 |
0.31 |
(-0.92, 0.28) |
-1.06 |
0.290 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.65 |
0.38 |
(-0.08, 1.39) |
1.74 |
0.082 |
| Belief (Real) |
-0.34 |
0.08 |
(-0.50, -0.19) |
-4.48 |
< .001 |
| Belief (Fake) * IUS ProspectiveAnxiety |
0.87 |
0.70 |
(-0.50, 2.24) |
1.24 |
0.214 |
| Belief (Real) * IUS ProspectiveAnxiety |
1.27 |
0.70 |
(-0.10, 2.63) |
1.82 |
0.069 |
| Belief (Fake) * IUS InhibitoryAnxiety |
-0.73 |
0.54 |
(-1.78, 0.32) |
-1.36 |
0.175 |
| Belief (Real) * IUS InhibitoryAnxiety |
-0.93 |
0.54 |
(-1.98, 0.13) |
-1.73 |
0.084 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)
Paranoid Beliefs
f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.35 |
0.12 |
(0.12, 0.59) |
2.91 |
0.004 |
| GPTS Reference |
-0.60 |
0.35 |
(-1.29, 0.10) |
-1.69 |
0.091 |
| GPTS Persecution |
0.53 |
0.32 |
(-0.10, 1.17) |
1.64 |
0.101 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
1.08 |
0.19 |
(0.71, 1.45) |
5.77 |
< .001 |
| Belief (Real) |
-0.24 |
0.04 |
(-0.31, -0.16) |
-6.25 |
< .001 |
| Belief (Fake) * GPTS Reference |
-0.91 |
0.63 |
(-2.14, 0.32) |
-1.44 |
0.149 |
| Belief (Real) * GPTS Reference |
-0.86 |
0.63 |
(-2.09, 0.37) |
-1.37 |
0.170 |
| Belief (Fake) * GPTS Persecution |
0.46 |
0.57 |
(-0.66, 1.59) |
0.80 |
0.421 |
| Belief (Real) * GPTS Persecution |
0.61 |
0.57 |
(-0.51, 1.73) |
1.06 |
0.288 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)
AI
rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)
efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
##
## Variable | MR1 | MR2 | MR3 | Complexity | Uniqueness
## -----------------------------------------------------------------------------
## AI_8_Exciting | 0.81 | 0.16 | 0.16 | 1.16 | 0.30
## AI_4_DailyLife | 0.77 | 0.16 | 0.16 | 1.18 | 0.36
## AI_9_Applications | 0.70 | 0.06 | 0.09 | 1.05 | 0.50
## AI_7_RealisticVideos | 0.10 | 0.79 | 0.11 | 1.07 | 0.35
## AI_5_ImitatingReality | 0.30 | 0.64 | 2.83e-03 | 1.42 | 0.50
## AI_1_RealisticImages | 0.16 | 0.54 | 0.07 | 1.21 | 0.68
## AI_3_VideosReal | -0.15 | 0.41 | -0.24 | 1.92 | 0.76
## AI_2_Unethical | 0.18 | 0.08 | 0.73 | 1.14 | 0.43
## AI_6_Dangerous | 0.15 | -0.12 | 0.59 | 1.20 | 0.61
## AI_10_FaceErrors | 7.75e-03 | 0.03 | 0.24 | 1.04 | 0.94
##
## The 3 latent factors (varimax rotation) accounted for 45.62% of the total variance of the original data (MR1 = 19.22%, MR2 = 15.65%, MR3 = 10.75%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.28 |
0.08 |
(0.12, 0.43) |
3.49 |
< .001 |
| AI Enthusiasm |
-0.01 |
0.06 |
(-0.13, 0.10) |
-0.25 |
0.802 |
| AI Realness |
0.07 |
0.06 |
(-0.04, 0.19) |
1.23 |
0.218 |
| AI Danger |
0.10 |
0.06 |
(-0.03, 0.22) |
1.53 |
0.127 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.87 |
0.09 |
(0.70, 1.05) |
9.71 |
< .001 |
| Belief (Real) |
-0.18 |
0.02 |
(-0.22, -0.15) |
-9.71 |
< .001 |
| Belief (Fake) * AI Enthusiasm |
0.30 |
0.10 |
(0.10, 0.49) |
2.97 |
0.003 |
| Belief (Real) * AI Enthusiasm |
0.21 |
0.10 |
(0.01, 0.41) |
2.10 |
0.036 |
| Belief (Fake) * AI Realness |
0.10 |
0.10 |
(-0.10, 0.30) |
0.95 |
0.340 |
| Belief (Real) * AI Realness |
0.15 |
0.10 |
(-0.05, 0.35) |
1.46 |
0.144 |
| Belief (Fake) * AI Danger |
-0.07 |
0.11 |
(-0.29, 0.15) |
-0.65 |
0.514 |
| Belief (Real) * AI Danger |
0.06 |
0.11 |
(-0.16, 0.28) |
0.53 |
0.594 |
p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") +
labs(x = "Enthusiasm about AI technology")
p_ai
r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -----------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.22 | [ 0.07, 0.36] | 99.62%** | Beta (5.20 +- 5.20) | 10.76** | 13.83**
## Confidence_Real | AI_Enthusiasm | 0.17 | [ 0.02, 0.32] | 98.00%* | Beta (5.20 +- 5.20) | 2.26 | 2.42
## Confidence_Fake | AI_Realness | 0.14 | [-0.01, 0.29] | 95.60% | Beta (5.20 +- 5.20) | 1.05 | 1.31
##
## Observations: 140
Figures
fig1a <- (rez_at$p +
theme(axis.text.x = element_blank()) +
labs(x = "Attractiveness") |
rez_gl$p +
labs(x = "Beauty") +
theme(
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
) /
(rez_tr$p +
labs(x = "Trustworthiness") |
rez_fa$p +
labs(x = "Familiarity") +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank()
)
) +
plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
plot_layout(guides = "collect") &
theme(legend.position='top', legend.title = element_blank())
fig <- wrap_elements(fig1a) /
wrap_elements(
# ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) +
((p_ffni1 / p_ipip) | (p_ffni2 / p_ai)) +
plot_layout(guides = "collect") +
plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
param <- cor_test(dfsub, x, y, bayesian = TRUE)
# Format stat output
r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")
stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")
label <- data.frame(
x = min(dfsub[[x]], na.rm = TRUE),
y = max(dfsub[[y]], na.rm = TRUE),
label = stat
)
# Plot
dfsub |>
ggplot(aes_string(x = x, y = y)) +
geom_point2(
size = 3,
color = fillx,
# color = DVs[x],
alpha = 2 / 3
) +
geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
labs(y = ylab, x = xlab) +
geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fillx, color = "white") +
ggside::geom_ysidedensity(fill = fill, color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
}
p1 <- plot_correlation(dfsub,
x = "IPIP6_HonestyHumility",
y = "Confidence_Real",
ylab = "Confidence that the stimulus is real",
xlab = "Honesty-Humility",
fillx = "#00BCD4",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p2 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is fake",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p3 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is real",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p4 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p5 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is fake",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p6 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_GrandioseFantasies",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Grandiose Fantasies)",
fillx = "#FFC107",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
fig <- wrap_elements(fig1a) /
wrap_elements(
((p3 / p2) | (p1 / p6) | (p4 / p5)) +
plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
Social Anxiety